COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 Browse in QLambda
C00005 00003	(m-defun browse ()
C00007 00004	(m-defun investigate (units pats)
C00008 ENDMK
C⊗;
;;; Browse in QLambda

(fasload browse)

(m-defun match (pat dat alist)
	 (qcatch 'match (match1 pat dat alist)))

(m-defun match1 (pat dat alist)
       (cond ((null pat)
	      (cond ((null dat)
		     (throw 'match t))))
	     ((null dat) ())
	     ((or (eq (car pat) '?)
		  (eq (car pat)
		      (car dat)))
	      (match1 (cdr pat) (cdr dat) alist))
	     ((eq (car pat) '*)
	      (funcall (qlambda t () (match1 (cdr pat) dat alist)) ())
	      (funcall (qlambda t () (match1 (cdr pat) (cdr dat) alist)) ())
	      (match1 pat (cdr dat) alist))
	     (t (cond ((atom (car pat))
		       (cond ((eq (char1 (car pat)) '?)
			      (let ((val (assq (car pat) alist)))
				   (cond (val (match1 (cons (cdr val)
							   (cdr pat))
						     dat alist))
					 (t (match1 (cdr pat)
						   (cdr dat)
						   (cons (cons (car pat)
							       (car dat))
							 alist))))))
			     ((eq (char1 (car pat)) '*)
			      (let ((val (assq (car pat) alist)))
				   (cond (val 
					  (match1 (append (cdr val)
							  (cdr pat))
						  dat alist))
					 (t 
					  (do ((l () (append l (ncons (car d))))
					       (e (cons () dat) (cdr e))
					       (d dat (cdr d)))
					      ((null e) ())
					      (funcall
					       (qlambda t () 
							(match1 (cdr pat) d
							       (cons (cons (car pat) 
									   l)
								     alist))) ())
					      ())))))))
		      (t (and 
			  (not (atom (car dat)))
			  (qcatch 'match (match1 (car pat)
						 (car dat) alist))
			  (match1 (cdr pat)
				  (cdr dat) alist)))))))

(m-defun browse ()
	 (seed)
	 (investigate 
	  (randomize 
	   (init 5. 5. 4. '((a a a b b b b a)
			    (a a (a a)(b b))
			    (a a a b (b a) b a b a))))
	  '((*a ?b *b ?b a)
	    (*a (*a) (*b))
	    (? ? * (b a) * ? ?))))

(m-defun investigate (units pats)
  (qcatch 'investigate
	  (do ((units units (cdr units)))
	      ((null units))
	      (do ((pats pats (cdr pats)))
		  ((null pats))
		  (do ((p (get (car units) 'pattern)
			  (cdr p)))
		      ((null p))
 		      (funcall (qlambda t () (match (car pats) (car p) ())) ())
		      ())))))
  

(m-defun investigate (units pats)
  (qcatch 'investigate
	  (do ((units units (cdr units)))
	      ((null units))
	      (do ((pats pats (cdr pats)))
		  ((null pats))
		  (do ((p (get (car units) 'pattern)
			  (cdr p)))
		      ((null p))
 		      (print (list 'unit '= (car units)
 				   'pat '= (car pats) 'dat '= (car p)))
 		      (funcall 
		       (qlambda t () (print (list (car pats) (car p) ()))) ())
		      ())))))